(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open Logging
open ParseState
open UniTools
open XNum
  
module SymbolMap = SymbolTable.SymbolMap
  
(* symbols *)
let decl_sym str = Machine.string_to_symbol (UString.uc_string_of_ascii str)
  
let sym_Accent = decl_sym "Accent"
let sym_AddToGalley = decl_sym "AddToGalley"
let sym_AdjDemerits = decl_sym "AdjDemerits"
let sym_Adjustments = decl_sym "Adjustments"
let sym_AFM = decl_sym "AFM"
let sym_Alignment = decl_sym "Alignment"
let sym_AutoLigatures = decl_sym "AutoLigatures"
let sym_Base = decl_sym "Base"
let sym_BaselineSkip = decl_sym "BaselineSkip"
let sym_BeginGroup = decl_sym "BeginGroup"
let sym_Bevel = decl_sym "Bevel"
let sym_BinOp = decl_sym "BinOp"
let sym_BinOpPenalty = decl_sym "BinOpPenalty"
let sym_Bitmap = decl_sym "Bitmap"
let sym_Bmp = decl_sym "Bmp"
let sym_Bool = decl_sym "Bool"
let sym_BorderKern = decl_sym "BorderKern"
let sym_Bottom = decl_sym "Bottom"
let sym_BottomSkip = decl_sym "BottomSkip"
let sym_Break = decl_sym "Break"
let sym_Butt = decl_sym "Butt"
let sym_Circle = decl_sym "Circle"
let sym_Clip = decl_sym "Clip"
let sym_Close = decl_sym "Close"
let sym_ClubPenalty = decl_sym "ClubPenalty"
let sym_CMYK = decl_sym "CMYK"
let sym_Command = decl_sym "Command"
let sym_CommandBox = decl_sym "CommandBox"
let sym_CrampedDisplay = decl_sym "CrampedDisplay"
let sym_CrampedScript = decl_sym "CrampedScript"
let sym_CrampedScript2 = decl_sym "CrampedScriptScript"
let sym_CrampedText = decl_sym "CrampedText"
let sym_Default = decl_sym "Default"
let sym_DelimiterFactor = decl_sym "DelimiterFactor"
let sym_DelimiterShortfall = decl_sym "DelimiterShortfall"
let sym_Direct = decl_sym "Direct"
let sym_Display = decl_sym "Display"
let sym_DoubleHyphenDemerits = decl_sym "DoubleHyphenDemerits"
let sym_Dpi = decl_sym "Dpi"
let sym_EmergencyStretch = decl_sym "EmergencyStretch"
let sym_Encoding = decl_sym "Encoding"
let sym_EndGroup = decl_sym "EndGroup"
let sym_ExHyphenPenalty = decl_sym "ExHyphenPenalty"
let sym_Family = decl_sym "Family"
let sym_Fill = decl_sym "Fill"
let sym_FinalHyphenDemerits = decl_sym "FinalHyphenDemerits"
let sym_Fixed = decl_sym "Fixed"
let sym_Float = decl_sym "Float"
let sym_FloatSep = decl_sym "FloatSep"
let sym_Footnote = decl_sym "Footnote"
let sym_Fraction = decl_sym "Fraction"
let sym_Galley = decl_sym "Galley"
let sym_GfxCommand = decl_sym "GfxCommand"
let sym_Glyph = decl_sym "Glyph"
let sym_Glue = decl_sym "Glue"
let sym_Grey = decl_sym "Grey"
let sym_GridSize = decl_sym "GridSize"
let sym_HBox = decl_sym "HBox"
let sym_HBoxSpread = decl_sym "HBoxSpread"
let sym_HBoxTo = decl_sym "HBoxTo"
let sym_Height = decl_sym "Height"
let sym_HLeaders = decl_sym "HLeaders"
let sym_Hyphen = decl_sym "Hyphen"
let sym_HyphenGlyph = decl_sym "HyphenGlyph"
let sym_HyphenParams = decl_sym "HyphenParams"
let sym_HyphenPenalty = decl_sym "HyphenPenalty"
let sym_HyphenTable = decl_sym "HyphenTable"
let sym_Image = decl_sym "Image"
let sym_IndexPosition = decl_sym "IndexPosition"
let sym_Inner = decl_sym "Inner"
let sym_Kern = decl_sym "Kern"
let sym_Leading = decl_sym "Leading"
let sym_Left = decl_sym "Left"
let sym_LeftHyphenMin = decl_sym "LeftHyphenMin"
let sym_LeftRight = decl_sym "LeftRight"
let sym_LeftSkip = decl_sym "LeftSkip"
let sym_Letter = decl_sym "Letter"
let sym_LetterSpacing = decl_sym "LetterSpacing"
let sym_Ligature = decl_sym "Ligature"
let sym_LineBreakParams = decl_sym "LineBreakParams"
let sym_LineParams = decl_sym "LineParams"
let sym_LinePenalty = decl_sym "LinePenalty"
let sym_LineSkip = decl_sym "LineSkip"
let sym_LineSkipLimit = decl_sym "LineSkipLimit"
let sym_Looseness = decl_sym "Looseness"
let sym_LR = decl_sym "LR"
let sym_LRBox = decl_sym "LRBox"
let sym_Mandatory = decl_sym "Mandatory"
let sym_Math = decl_sym "Math"
let sym_MathAccent = decl_sym "MathAccent"
let sym_MathChar = decl_sym "MathChar"
let sym_MathCode = decl_sym "MathCode"
let sym_MathFamily = decl_sym "MathFamily"
let sym_MathParams = decl_sym "MathParams"
let sym_MathStyle = decl_sym "MathStyle"
let sym_Measure = decl_sym "Measure"
let sym_MedMathSkip = decl_sym "MedMathSkip"
let sym_MinSize = decl_sym "MinSize"
let sym_Miter = decl_sym "Miter"
let sym_ModifyGalleyGlue = decl_sym "ModifyGalleyGlue"
let sym_Name = decl_sym "Name"
let sym_NewArea = decl_sym "NewArea"
let sym_NewGalley = decl_sym "NewGalley"
let sym_NewLayout = decl_sym "NewLayout"
let sym_NewMarks = decl_sym "NewMarks"
let sym_NoMath = decl_sym "NoMath"
let sym_None = decl_sym "None"
let sym_NullDelimiterSpace = decl_sym "NullDelimiterSpace"
let sym_OldMarks = decl_sym "OldMarks"
let sym_Open = decl_sym "Open"
let sym_OpenType = decl_sym "OpenType"
let sym_Operator = decl_sym "Operator"
let sym_Optional = decl_sym "Optional"
let sym_Ordinary = decl_sym "Ordinary"
let sym_Overline = decl_sym "Overline"
let sym_PageNo = decl_sym "PageNo"
let sym_Paragraph = decl_sym "Paragraph"
let sym_ParIndent = decl_sym "ParIndent"
let sym_ParFillSkip = decl_sym "ParFillSkip"
let sym_ParParams = decl_sym "ParParams"
let sym_ParShape = decl_sym "ParShape"
let sym_ParSkip = decl_sym "ParSkip"
let sym_PDF = decl_sym "PDF"
let sym_Phantom = decl_sym "Phantom"
let sym_PK = decl_sym "PK"
let sym_PositionBox = decl_sym "PositionBox"
let sym_PostProcessLine = decl_sym "PostProcessLine"
let sym_PostScript = decl_sym "PostScript"
let sym_Preamble = decl_sym "Preamble"
let sym_PreTolerance = decl_sym "PreTolerance"
let sym_Punct = decl_sym "Punct"
let sym_PutBox = decl_sym "PutBox"
let sym_PutGalleyInVBox = decl_sym "PutGalleyInVBox"
let sym_Register = decl_sym "Register"
let sym_Relation = decl_sym "Relation"
let sym_RelPenalty = decl_sym "RelPenalty"
let sym_RGB = decl_sym "RGB"
let sym_Right = decl_sym "Right"
let sym_RightHyphenMin = decl_sym "RightHyphenMin"
let sym_RightSkip = decl_sym "RightSkip"
let sym_RiverDemerits = decl_sym "RiverDemerits"
let sym_RiverThreshold = decl_sym "RiverThreshold"
let sym_RL = decl_sym "RL"
let sym_RLBox = decl_sym "RLBox"
let sym_Root = decl_sym "Root"
let sym_Round = decl_sym "Round"
let sym_Rule = decl_sym "Rule"
let sym_Scale = decl_sym "Scale"
let sym_Script = decl_sym "Script"
let sym_Script2 = decl_sym "ScriptScript"
let sym_ScriptLang = decl_sym "ScriptLang"
let sym_ScriptSpace = decl_sym "ScriptSpace"
let sym_ScriptSize = decl_sym "ScriptSize"
let sym_Script2Size = decl_sym "ScriptScriptSize"
let sym_Separator = decl_sym "Separator"
let sym_Series = decl_sym "Series"
let sym_SetAlpha = decl_sym "SetAlpha"
let sym_SetBgColour = decl_sym "SetBgColour"
let sym_SetColour = decl_sym "SetColour"
let sym_SetFont = decl_sym "SetFont"
let sym_SetLineCap = decl_sym "SetLineCap"
let sym_SetLineJoin = decl_sym "SetLineJoin"
let sym_SetLineWidth = decl_sym "SetLineWidth"
let sym_SetMiterLimit = decl_sym "SetMiterLimit"
let sym_Shape = decl_sym "Shape"
let sym_ShipOut = decl_sym "ShipOut"
let sym_Shrink = decl_sym "Shrink"
let sym_ShrinkFactor = decl_sym "ShrinkFactor"
let sym_ShrinkOrder = decl_sym "ShrinkOrder"
let sym_SimpleBreaking = decl_sym "SimpleBreaking"
let sym_Size = decl_sym "Size"
let sym_Skew = decl_sym "Skew"
let sym_SkewGlyph = decl_sym "SkewGlyph"
let sym_Skyline = decl_sym "Skyline"
let sym_Source = decl_sym "Source"
let sym_Space = decl_sym "Space"
let sym_SpaceFactor = decl_sym "SpaceFactor"
let sym_SpaceParams = decl_sym "SpaceParams"
let sym_SpaceSkip = decl_sym "SpaceSkip"
let sym_Square = decl_sym "Square"
let sym_Stretch = decl_sym "Stretch"
let sym_StretchFactor = decl_sym "StretchFactor"
let sym_StretchOrder = decl_sym "StretchOrder"
let sym_Stroke = decl_sym "Stroke"
let sym_SubScript = decl_sym "SubScript"
let sym_SuperScript = decl_sym "SuperScript"
let sym_Table = decl_sym "Table"
let sym_TableEntry = decl_sym "TableEntry"
let sym_TeX = decl_sym "TeX"
let sym_Text = decl_sym "Text"
let sym_TextSize = decl_sym "TextSize"
let sym_TFM = decl_sym "TFM"
let sym_ThickMathSkip = decl_sym "ThickMathSkip"
let sym_ThinMathSkip = decl_sym "ThinMathSkip"
let sym_Tolerance = decl_sym "Tolerance"
let sym_Top = decl_sym "Top"
let sym_TopSkip = decl_sym "TopSkip"
let sym_TrueType = decl_sym "TrueType"
let sym_Type_1 = decl_sym "Type_1"
let sym_Underline = decl_sym "Underline"
let sym_VBox = decl_sym "VBox"
let sym_VBoxSpread = decl_sym "VBoxSpread"
let sym_VBoxTo = decl_sym "VBoxTo"
let sym_Vert = decl_sym "Vert"
let sym_VictorianSpacing = decl_sym "VictorianSpacing"
let sym_VInsert = decl_sym "VInsert"
let sym_WidowPenalty = decl_sym "WidowPenalty"
let sym_Width = decl_sym "Width"
let sym_WordEnd = decl_sym "WordEnd"
let sym_XSpaceSkip = decl_sym "XspaceSkip"
  
(* wrappers for various types *******************************************************************************)
let decode_symbol name x =
  match !x with
    | VMTypes.Symbol s -> s
    | _ ->
        VMTypes.runtime_error (name ^ (": symbol expected but got " ^ (VMTypes.type_name !x)))
  
let decode_int name x =
  let n = Machine.decode_num name x in
    if is_integer_num n then
      int_of_num n
    else
      VMTypes.runtime_error (name ^ ": integer expected but got arbitrary number")
  
let decode_bool name x =
  match !x with
    | VMTypes.Bool b -> b
    | _ ->
        VMTypes.runtime_error (name ^ (": bool expected but got " ^ (VMTypes.type_name !x)))
  
let decode_char name x =
  match !x with
    | VMTypes.Char c -> c
    | _ ->
        VMTypes.runtime_error (name ^ (": character expected but got " ^ (VMTypes.type_name !x)))
  
let decode_option name decode x =
  match !x with
    | VMTypes.Symbol s when s = sym_None -> None
    | _ -> Some (decode name x)
  
let decode_uc_string name x = Array.of_list (Machine.decode_string name x)
  
let decode_tuple name x =
  match !x with
    | VMTypes.Tuple z -> z
    | _ ->
        VMTypes.runtime_error (name ^ (": tuple expected but got " ^ (VMTypes.type_name !x)))
  
(* dictionaries *)
let decode_dict name x =
  match !x with
    | VMTypes.Dictionary d -> d
    | _ ->
        VMTypes.runtime_error (name ^ (": dictionary expected but got " ^ (VMTypes.type_name !x)))
  
let lookup decode dict key =
  try
    Some (decode (SymbolMap.find key dict))
  with
    | Not_found -> None
  
let lookup_string name dict key = lookup (decode_uc_string name) dict key
let lookup_bool name dict key = lookup (decode_bool name) dict key
let lookup_int name dict key = lookup (decode_int name) dict key
let lookup_num name dict key = lookup (Machine.decode_num name) dict key
let lookup_symbol name dict key = lookup (decode_symbol name) dict key
let lookup_dict name dict key = lookup (decode_dict name) dict key
let lookup_tuple name dict key = lookup (decode_tuple name) dict key
let lookup_list name dict key = lookup (Machine.decode_list name) dict key
  
(* generic unwrapper for opaque types *)
let decode_opaque type_name unwrapper name x =
  match !x with
    | VMTypes.Opaque y ->
        begin
          try unwrapper y
          with
            | Opaque.Type_error ->
                VMTypes.runtime_error
                  (name ^ (": " ^ (type_name ^ (" expected but got " ^ (VMTypes.type_name !x)))))
        end
    | _ ->
        VMTypes.runtime_error
          (name ^ (": " ^ (type_name ^ (" expected but got " ^ (VMTypes.type_name !x)))))
  
(* locations *)
let encode_location (file, line, col) =
  VMTypes.Tuple
    [| ref (Machine.uc_string_to_char_list (UniText.to_ints file));
       ref (VMTypes.Number (num_of_int line));
       ref (VMTypes.Number (num_of_int col)) |]
  
let decode_location name loc =
  match !loc with
    | VMTypes.Tuple [| file; line; col |] ->
        (UniText.of_int_list (Machine.decode_string name file),
         decode_int name line,
         decode_int name col)
    | _ -> VMTypes.runtime_error (name ^ ": invalid location")
  
(* index position *)
let encode_index_position s =
  match s with
    | Box.LeftIndex -> VMTypes.Symbol sym_Left
    | Box.RightIndex -> VMTypes.Symbol sym_Right
    | Box.VertIndex -> VMTypes.Symbol sym_Vert
  
let decode_index_position name s =
  match !s with
    | VMTypes.Symbol s ->
        if s = sym_Left then
          Box.LeftIndex
        else if s = sym_Right then
          Box.RightIndex
        else if s = sym_Vert then
          Box.VertIndex
        else
          VMTypes.runtime_error (name ^ ": invalid math style")
    | _ -> VMTypes.runtime_error (name ^ ": invalid math style")
  
(* math-code *)
let encode_math_code c =
  match c with
    | Box.NoMath -> VMTypes.Symbol sym_NoMath
    | Box.Ordinary -> VMTypes.Symbol sym_Ordinary
    | Box.BinOp -> VMTypes.Symbol sym_BinOp
    | Box.Relation -> VMTypes.Symbol sym_Relation
    | Box.Operator -> VMTypes.Symbol sym_Operator
    | Box.Punct -> VMTypes.Symbol sym_Punct
    | Box.Open -> VMTypes.Symbol sym_Open
    | Box.Close -> VMTypes.Symbol sym_Close
    | Box.Inner -> VMTypes.Symbol sym_Inner
    | Box.SubScript -> VMTypes.Symbol sym_SubScript
    | Box.SuperScript -> VMTypes.Symbol sym_SuperScript
    | Box.IndexPosition p ->
        VMTypes.Tuple
          [| ref (VMTypes.Symbol sym_IndexPosition);
             ref (encode_index_position p) |]
  
let decode_math_code name c =
  match !c with
    | VMTypes.Symbol s ->
        if s = sym_NoMath then
          Box.NoMath
        else if s = sym_Ordinary then
          Box.Ordinary
        else if s = sym_BinOp then
          Box.BinOp
        else if s = sym_Relation then
          Box.Relation
        else if s = sym_Operator then
          Box.Operator
        else if s = sym_Punct then
          Box.Punct
        else if s = sym_Open then
          Box.Open
        else if s = sym_Close then
          Box.Close
        else if s = sym_Inner then
          Box.Inner
        else if s = sym_SubScript then
          Box.SubScript
        else if s = sym_SuperScript then
          Box.SuperScript
        else
          VMTypes.runtime_error (name ^ ": invalid math code")
    | VMTypes.Tuple [| a; b |] ->
        begin
          match !a with
            | VMTypes.Symbol s ->
                if s = sym_IndexPosition then
                  Box.IndexPosition (decode_index_position name b)
                else
                  VMTypes.runtime_error (name ^ ": invalid math code")
            | _ -> VMTypes.runtime_error (name ^ ": invalid math code")
        end
    | _ -> VMTypes.runtime_error (name ^ ": invalid math code")
  
(* math-style *)
let encode_math_style s =
  match s with
    | MathLayout.Display -> VMTypes.Symbol sym_Display
    | MathLayout.CrampedDisplay -> VMTypes.Symbol sym_CrampedDisplay
    | MathLayout.Text -> VMTypes.Symbol sym_Text
    | MathLayout.CrampedText -> VMTypes.Symbol sym_CrampedText
    | MathLayout.Script -> VMTypes.Symbol sym_Script
    | MathLayout.CrampedScript -> VMTypes.Symbol sym_CrampedScript
    | MathLayout.Script2 -> VMTypes.Symbol sym_Script2
    | MathLayout.CrampedScript2 -> VMTypes.Symbol sym_CrampedScript2
  
let decode_math_style name s =
  match !s with
    | VMTypes.Symbol s ->
        if s = sym_Display then
          MathLayout.Display
        else if s = sym_CrampedDisplay then
          MathLayout.CrampedDisplay
        else if s = sym_Text then
          MathLayout.Text
        else if s = sym_CrampedText then
          MathLayout.CrampedText
        else if s = sym_Script then
          MathLayout.Script
        else if s = sym_CrampedScript then
          MathLayout.CrampedScript
        else if s = sym_Script2 then
          MathLayout.Script2
        else if s = sym_CrampedScript2 then
          MathLayout.CrampedScript2
        else VMTypes.runtime_error (name ^ ": invalid math style")
    | _ -> VMTypes.runtime_error (name ^ ": invalid math style")
  
(* modes *)
let encode_mode m =
  match m with
    | `Preamble -> VMTypes.Symbol sym_Preamble
    | `Galley -> VMTypes.Symbol sym_Galley
    | `Paragraph -> VMTypes.Symbol sym_Paragraph
    | `Math -> VMTypes.Symbol sym_Math
    | `HBox -> VMTypes.Symbol sym_HBox
    | `LRBox -> VMTypes.Symbol sym_LRBox
    | `RLBox -> VMTypes.Symbol sym_RLBox
    | `VBox -> VMTypes.Symbol sym_VBox
    | `Table -> VMTypes.Symbol sym_Table
  
let decode_mode name m =
  match !m with
    | VMTypes.Symbol s ->
        if s = sym_Preamble then
          `Preamble
        else if s = sym_Galley then
          `Galley
        else if s = sym_Paragraph then
          `Paragraph
        else if s = sym_Math then
          `Math
        else if s = sym_HBox then
          `HBox
        else if s = sym_LRBox then
          `LRBox
        else if s = sym_RLBox then
          `RLBox
        else if s = sym_VBox then
          `VBox
        else if s = sym_Table then
          `Table
        else
          VMTypes.runtime_error (name ^ ": invalid mode")
    | _ -> VMTypes.runtime_error (name ^ ": invalid mode")
  
let encode_hbox_dir d =
  match d with
    | `LR -> VMTypes.Symbol sym_LR
    | `RL -> VMTypes.Symbol sym_RL
    | `Default -> VMTypes.Symbol sym_Default
  
let decode_hbox_dir name d =
  match !d with
    | VMTypes.Symbol s ->
        if s = sym_LR then
          `LR
        else if s = sym_RL then
          `RL
        else if s = sym_Default then
          `Default
        else
          VMTypes.runtime_error (name ^ ": invalid direction")
    | _ -> VMTypes.runtime_error (name ^ ": invalid direction")
  
(* colours *)
let encode_colour col =
  match col with
    | Graphic.Grey x ->
        VMTypes.Tuple [| ref (VMTypes.Symbol sym_Grey);
                         ref (VMTypes.Number x) |]
    | Graphic.RGB (r, g, b) ->
        VMTypes.Tuple
          [| ref (VMTypes.Symbol sym_RGB);
             ref (VMTypes.Number r);
             ref (VMTypes.Number g);
             ref (VMTypes.Number b) |]
    | Graphic.CMYK (c, m, y, k) ->
        VMTypes.Tuple
          [| ref (VMTypes.Symbol sym_CMYK);
             ref (VMTypes.Number c);
             ref (VMTypes.Number m);
             ref (VMTypes.Number y);
             ref (VMTypes.Number k) |]
  
let decode_colour name col =
  match !col with
    | VMTypes.Tuple xs ->
        (match !(xs.(0)) with
           | VMTypes.Symbol s ->
               if s = sym_Grey then
                 match xs with
                   | [| _; x |] -> Graphic.Grey (Machine.decode_num name x)
                   | _ -> VMTypes.runtime_error (name ^ ": colour expected")
               else if s = sym_RGB then
                 match xs with
                   | [| _; r; g; b |] ->
                       Graphic.RGB (Machine.decode_num name r,
                                    Machine.decode_num name g,
                                    Machine.decode_num name b)
                   | _ -> VMTypes.runtime_error (name ^ ": colour expected")
               else if s = sym_CMYK then
                 match xs with
                   | [| _; c; m; y; k |] ->
                       Graphic.CMYK (Machine.decode_num name c,
                                     Machine.decode_num name m,
                                     Machine.decode_num name y,
                                     Machine.decode_num name k)
                   | _ -> VMTypes.runtime_error (name ^ ": colour expected")
               else
                 VMTypes.runtime_error (name ^ ": colour expected")
           | _ ->
               VMTypes.runtime_error (name ^ ": colour expected"))
    | _ ->
        VMTypes.runtime_error (name ^ ": colour expected")
